TOS Silver 2000

home *** CD-ROM | disk | FTP | other *** search

/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / MYUTIL / COMPTREE.I < prev next >

Wrap

Text File | 1993-12-30 | 11.0 KB | 3 lines

⓪ IMPLEMENTATION MODULE CompTree;⓪ ⓪ (*$Y+,H+,Z+*)⓪ ⓪ (*⓪ IMPORT TOSDebug;⓪ *)⓪ ⓪ (*$N+*)⓪ IMPORT Runtime;⓪ FROM SYSTEM IMPORT ADDRESS, ASSEMBLER, BYTE;⓪ FROM Strings IMPORT String, StrEqual, Assign, Append;⓪ FROM Storage IMPORT ALLOCATE, DEALLOCATE, MemAvail;⓪ IMPORT Files, Binary;⓪ ⓪ TYPE PtrPtr = POINTER TO PtrItem;⓪ ⓪ VAR Code: ADDRESS;⓪$ok: BOOLEAN;⓪ ⓪ PROCEDURE ptr (item: PtrItem; ofs: LONGINT): PtrItem;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L (A0),D0⓪$END⓪"END ptr;⓪"(*$L=*)⓪ ⓪ PROCEDURE long (item: PtrItem; ofs: LONGINT): LONGCARD;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.L (A0),D0⓪$END⓪"END long;⓪"(*$L=*)⓪ ⓪ PROCEDURE card (item: PtrItem; ofs: LONGINT): CARDINAL;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.W (A0),D0⓪$END⓪"END card;⓪"(*$L=*)⓪ ⓪ PROCEDURE int (item: PtrItem; ofs: LONGINT): INTEGER;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.W (A0),D0⓪$END⓪"END int;⓪"(*$L=*)⓪ ⓪ PROCEDURE byte (item: PtrItem; ofs: LONGINT): BYTE;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(MOVE.L -(A3),A0⓪(ADDA.L -(A3),A0⓪(ADDA.L TreeBase,A0⓪(MOVE.B (A0),D0⓪$END⓪"END byte;⓪"(*$L=*)⓪ ⓪ (*$D-*)⓪ ⓪ PROCEDURE ScanWholeTree (scanner: TreeProc; new: NewTreeProc);⓪"VAR tr: PtrItem; sp: PtrPtr; tt: TreeType;⓪"BEGIN⓪$sp:= PtrPtr (DisplayStack);⓪$LOOP⓪&tr:= sp^;⓪&IF tr = 1 THEN EXIT END;⓪&INC (sp, SIZE (sp^));⓪&IF tr = 0 THEN⓪(IF new (newscope) THEN END⓪&ELSE⓪(IF sp^ = 1 THEN tt:= global ELSE tt:= local END;⓪(IF new (tt) THEN⓪*ScanLocalTree (scanner, tr)⓪(END⓪&END⓪$END;⓪$(* Relocation Stack abarbeiten (lokale Module) *)⓪$sp:= RelocationStack;⓪$WHILE sp^ # NoItem DO⓪&IF new (module) THEN⓪(ScanLocalTree (scanner, sp^);⓪&END;⓪&INC (sp, SIZE (sp^))⓪$END;⓪$IF new (pervasive) THEN⓪&ScanLocalTree (scanner, 0); (* pervasives *)⓪$END⓪"END ScanWholeTree;⓪ ⓪ PROCEDURE fetch (VAR ptr: PtrItem; VAR name: ARRAY OF CHAR);⓪"(*⓪#* Liest Namen aus Baum ein. 'ptr' muß auf das Zeichen vor dem Namen zeigen⓪#* hinterher zeigt 'ptr' hinter den Text.⓪#*)⓪"VAR (*$Reg*)c: CARDINAL; (*$Reg*)by: BYTE;⓪"BEGIN⓪$c:= 0;⓪$LOOP⓪&IF (c+1) > HIGH (name) THEN HALT END;⓪&DEC (ptr);⓪&by:= byte (ptr, 0);⓪&IF ORD (by) >= $FE THEN⓪(IF ORD (byte (ptr, 0)) = $FE THEN DEC (ptr); END;⓪(IF c = 0 THEN⓪*name[0]:= '*'; (* anonym-Kennung *)⓪*c:= 1⓪(END;⓪(name[c]:= 0C;⓪(RETURN⓪&END;⓪&name [c]:= CHR (ORD (by));⓪&INC (c)⓪$END⓪"END fetch;⓪ ⓪ (*$D-*)⓪ ⓪ PROCEDURE ScanLocalTree (scanner: TreeProc; tree: PtrItem);⓪ ⓪"FORWARD scan (tree: PtrItem);⓪ ⓪"PROCEDURE doit (it: PtrItem);⓪$VAR name: String; c: CARDINAL;⓪$BEGIN⓪&fetch (it, name);⓪&(* Relays werden direkt gemeldet⓪(IF ORD (byte (it, -1)) = 0 THEN⓪*(* relay *)⓪*it:= ptr (it, -6)⓪(END;⓪&*)⓪&(* IF int (it, -2) < 0 THEN (* kein Modula-Wort, sondern User-ID *) *)⓪((* auch dies muß der 'scanner' selbst veranlassen⓪*c:= ORD (byte (it, -1));⓪*IF (c=15) (* lok.Modul *) OR (c=16) (* qualifier *) THEN⓪,IF ptr (it, -6) # NoItem THEN scan (ptr (it, -6)) END⓪*END;⓪(*)⓪(scanner (name, it)⓪&(* END *)⓪$END doit;⓪ ⓪"PROCEDURE scan (tree: PtrItem);⓪$(* lokale Funktion, um Stackplatz f. Rekursion zu sparen *)⓪$VAR it: PtrItem;⓪$BEGIN⓪&(* linker Ast *)⓪&it:= ptr (tree, -4);⓪&IF it # NoItem THEN⓪(scan (it);⓪&END;⓪&(* rechter Ast *)⓪&it:= ptr (tree, -8);⓪&IF it # NoItem THEN⓪(scan (it);⓪&END;⓪&doit (tree - 8)⓪$END scan;⓪$⓪"BEGIN⓪$scan (tree);⓪"END ScanLocalTree;⓪ ⓪ PROCEDURE FindItemByName (REF name: ARRAY OF CHAR; VAR item: PtrItem);⓪"⓪"PROCEDURE scanTree (REF currname: ARRAY OF CHAR; curritem: PtrItem);⓪$BEGIN⓪&(* nur ersten gefundenen Namen übernehmen *)⓪&IF item = NoItem THEN⓪(IF StrEqual (name, currname) THEN⓪*item:= curritem⓪(END⓪&END⓪$END scanTree;⓪"⓪"PROCEDURE newTree (typ: TreeType): BOOLEAN;⓪$BEGIN⓪&(* nur lokale/globale Level *)⓪&RETURN (typ <= global)⓪$END newTree;⓪"⓪"BEGIN⓪$item:= NoItem;⓪$ScanWholeTree (scanTree, newTree);⓪"END FindItemByName;⓪ ⓪ PROCEDURE GetNameOfItem (item: PtrItem;⓪9VAR name: ARRAY OF CHAR; VAR found: BOOLEAN);⓪"⓪"PROCEDURE scanTree (REF currname: ARRAY OF CHAR; curritem: PtrItem);⓪$BEGIN⓪&IF item = curritem THEN⓪(found:= TRUE;⓪(Assign (currname, name, ok)⓪&END⓪$END scanTree;⓪"⓪"PROCEDURE newTree (typ: TreeType): BOOLEAN;⓪$BEGIN⓪&(* alle Level *)⓪&RETURN TRUE⓪$END newTree;⓪"⓪"BEGIN⓪$found:= FALSE;⓪$name[0]:= 0C;⓪$ScanWholeTree (scanTree, newTree);⓪"END GetNameOfItem;⓪ ⓪ PROCEDURE GetItemDesc (item: PtrItem; VAR desc: ItemDesc): BOOLEAN;⓪"BEGIN⓪$IF item = NoItem THEN⓪&RETURN FALSE⓪$ELSE⓪&WITH desc DO⓪(flag:= ItemFlags (byte (item, -2));⓪(kind:= ORD (byte (item, -1))⓪&END;⓪&RETURN TRUE⓪$END⓪"END GetItemDesc;⓪ ⓪ PROCEDURE SystemType (REF desc: ItemDesc): BOOLEAN;⓪"TYPE FS = SET OF [0..63];⓪"BEGIN⓪$RETURN desc.kind IN FS {1,2,3,4,21,22,23,24,25,26,27,29,⓪<30,31,33,34,35,36,37,38,39,40,41,43}⓪"END SystemType;⓪"⓪ PROCEDURE Kind (REF desc: ItemDesc): String;⓪"VAR name: String;⓪"BEGIN⓪$CASE desc.kind OF⓪$| 0: name:= "Relay"⓪$| 1: name:= "LONGINT"⓪$| 2: name:= "LONGREAL"⓪$| 3: name:= "CHAR"⓪$| 4: name:= "ZZ"⓪$| 5: name:= "SET(large)"⓪$| 6: name:= "Prozedur"⓪$| 7: name:= "Parameter"⓪$| 8: name:= "Opaque"⓪$| 9: name:= "Enum-Typ"⓪$|10: name:= "Enum-Elem"⓪$|11: name:= "Subrange"⓪$|12: name:= "ARRAY"⓪$|13: name:= "RECORD"⓪$|14: name:= "Rec-Feld"⓪$|15: name:= "Lok.Modul"⓪$|16: name:= "Qualifier"⓪$|17: name:= "Variable"⓪$|18: name:= "CONST(old)"⓪$|19: name:= "PROCEDURE"⓪$|20: name:= "POINTER"⓪$|21: name:= "WORD"⓪$|22: name:= "LONGCARD"⓪$|23: name:= "ADDRESS"⓪$|24: name:= "BOOLEAN"⓪$|25: name:= "Opaque"⓪$|26: name:= "LONGWORD"⓪$|27: name:= "String"⓪$|28: name:= "TABLE"⓪$|29: name:= "Asm-Label"⓪$|30: name:= "LONGBOTH"⓪$|31: name:= "StrConst"⓪$|32: name:= "OpenArray"⓪$|33: name:= "INTEGER"⓪$|34: name:= "CARDINAL"⓪$|35: name:= "SHORTBOTH"⓪$|36: name:= "StdFunc"⓪$|37: name:= "StdFunc-Parm"⓪$|38: name:= "BYTE"⓪$|39: name:= "BYTE(signed)"⓪$|40: name:= "REAL"⓪$|41: name:= "BITNUM"⓪$|42: name:= "LongOpArr"⓪$|43: name:= "StructConst"⓪$|44: name:= "Long-PROC-Typ"⓪$|45: name:= "SET(32Bit)"⓪$|46: name:= "Tag-Field"⓪$|47: name:= "Rec-Variante"⓪$|50: name:= "CONST(new)"⓪$ELSE⓪&name:= "???"⓪$END;⓪$RETURN name;⓪"END Kind;⓪ ⓪ PROCEDURE flag (REF desc: ItemDesc; flagNo: CARDINAL): String;⓪"VAR name: String;⓪"BEGIN⓪$WITH desc DO⓪&CASE flagNo OF⓪&| 7: name:= "Userdef"⓪&| 6: name:= "Exported"⓪&| 5: name:= "Imported"⓪&| 4: name:= "External"⓪&| 3: name:= "VAR-Parm"⓪&| 2: name:= "Type"⓪&| 1: IF 2 IN flag THEN name:= "Anonym" ELSE name:= "Global" END⓪&| 0: IF 2 IN flag THEN name:= "Scalar" ELSIF kind = 17 THEN⓪,name:= "Read-only" ELSE name:= "D0-Return" END⓪&END⓪$END;⓪$RETURN name;⓪"END flag;⓪ ⓪ PROCEDURE Flags (REF desc: ItemDesc): String;⓪"VAR name: String; i: CARDINAL; first: BOOLEAN;⓪"BEGIN⓪$name[0]:= 0C;⓪$first:= TRUE;⓪$FOR i:= 7 TO 0 BY -1 DO⓪&IF i IN desc.flag THEN⓪(IF NOT first THEN Append ('/', name, ok); END;⓪(Append (flag (desc, i), name, ok);⓪(first:= FALSE⓪&END⓪$END;⓪$RETURN name;⓪"END Flags;⓪ ⓪ PROCEDURE ItemTable;⓪"(*$L-*)⓪"BEGIN⓪$ASSEMBLER⓪(DC.W 0,1,0 ;Relay⓪(DC.W 6,2,1,1,2,7,8,0 ;PROC⓪(DC.W 5,2,1,0 ;SET⓪(DC.W 45,2,1,0 ;SET (neue Ordnung)⓪(DC.W 7,1,1,3,0 ;PARAM⓪(DC.W 8,2,0 ;REDECLARABLE OPAQUE⓪(DC.W 9,2,2,5,0 ;ENUM⓪(DC.W 10,3,1,5,0 ;ENUM.ELEMENT⓪(DC.W 11,2,2,2,1,0 ;SUBR⓪(DC.W 12,2,1,1,0 ;ARRAY⓪(DC.W 13,2,1,4,0 ;RECORD⓪(DC.W 14,2,1,1,0 ;REC.FELD⓪(DC.W 15,4,0 ;Lok. Modul⓪(DC.W 16,4,0 ;Qualifier⓪(DC.W 17,2,1,2,7,2,0;VAR⓪(DC.W 18,1,6,0 ;CONST⓪(DC.W 19,2,1,1,0 ;PROC.TYPE⓪(DC.W 20,2,1,0 ;PTR⓪(DC.W 25,2,0 ;OPAQUE⓪(DC.W 27,2,2,0 ;STRING⓪(DC.W 32,1,0 ;OPEN ARRAY⓪(DC.W 42,1,0 ;OPEN LONGARRAY⓪(DC.W 1,2,0 ;LINT⓪(DC.W 2,2,0 ;LONGREAL⓪(DC.W 3,2,0 ;CHAR⓪(DC.W 4,2,0 ;ZZ⓪(DC.W 21,2,0 ;WORD⓪(DC.W 22,2,0 ;LCARD⓪(DC.W 23,2,1,0 ;ADDRESS⓪(DC.W 24,2,0 ;BOOLEAN⓪(DC.W 26,2,0 ;LONG⓪(DC.W 30,2,0 ;LBOTH⓪(DC.W 33,2,0 ;SINT⓪(DC.W 34,2,0 ;SCARD⓪(DC.W 35,2,0 ;SBOTH⓪(DC.W 36,3,1,0 ;StandardProc⓪(DC.W 37,1,1,1,0 ;StandardProcParams⓪(DC.W 38,2,0 ;BYTE⓪(DC.W 39,2,0 ;Signed BYTE⓪(DC.W 40,2,0 ;REAL⓪(DC.W 41,2,0 ;BITNUM⓪(DC.W 43,2,0 ;untyped Constant⓪(DC.W 44,2,1,0 ;PROC.TYPE bei Parametern (8 Byte Länge)⓪(DC.W 46,1,2,2,1,0 ;Record-Tag⓪(DC.W 47,2,1,1,1,1,0;Rec-Variante⓪(DC.W 50,2,1,7,4,6,0 ;CONST neu (nun incl. String-Literals)⓪(DC.W 63,0 ;Dummy-Eintrag⓪(DC.W 0⓪$END⓪"END ItemTable;⓪"(*$L=*)⓪ ⓪ PROCEDURE ScanItem (scanner: ItemProc; item: PtrItem);⓪"VAR no: CARDINAL; pt: POINTER TO CARDINAL; entry: ItemEntry; ofs: INTEGER;⓪"BEGIN⓪$no:= ORD (byte (item, -1));⓪$(* zuerst die Item-Beschreibung in der Tabelle suchen *)⓪$ASSEMBLER⓪(LEA ItemTable,A0⓪(MOVE.L A0,pt(A6)⓪$END;⓪$LOOP⓪&IF no = pt^ THEN EXIT END;⓪&REPEAT INC (pt, 2); UNTIL pt^ = 0;⓪&INC (pt, 2);⓪&IF pt^ = 0 THEN HALT END (* Nicht gefunden! *)⓪$END;⓪$INC (pt, 2);⓪$ofs:= -2;⓪$LOOP⓪&no:= pt^;⓪&IF no = 0 THEN EXIT END;⓪&INC (pt, 2);⓪&WITH entry DO⓪(name:= '';⓪(CASE no OF⓪(| 1,5: type:= pointer; DEC (ofs, 4); ptrVal:= ptr (item, ofs);⓪(| 2: type:= const; DEC (ofs, 4); constVal:= long (item, ofs);⓪(| 3: type:= const; DEC (ofs, 2); constVal:= card (item, ofs);⓪(| 4: type:= scope; DEC (ofs, 4); ptrVal:= ptr (item, ofs);⓪(| 6: DEC (ofs, 2);⓪(| 7: DEC (ofs, pt^); INC (pt, 2);⓪(ELSE⓪*HALT⓪(END⓪&END;⓪&IF no <= 5 THEN scanner (entry, pt^ # 0) END;⓪$END;⓪"END ScanItem;⓪ ⓪ PROCEDURE LoadDef (REF name: ARRAY OF CHAR);⓪"VAR size, l: LONGCARD; f: Files.File;⓪"BEGIN⓪$IF Buffer # NIL THEN DEALLOCATE (Buffer, 0) END;⓪$⓪$size:= MemAvail () DIV 2; IF ODD (size) THEN DEC (size) END;⓪$ALLOCATE (Buffer, size);⓪$IF Buffer = NIL THEN HALT END;⓪$⓪$Files.Open (f, name, Files.readOnly);⓪$IF Binary.FileSize (f) * 4 > size THEN HALT END;⓪$Binary.ReadBytes (f, Buffer, Binary.FileSize (f), l);⓪$IF Binary.FileSize (f) # l THEN HALT END;⓪$Files.Close (f);⓪$⓪$Code:= Buffer + 8;⓪$⓪$(* ächz! *)⓪$⓪"END LoadDef;⓪ ⓪ END CompTree.⓪ ə (* $FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$00002315$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EE$FFEB02EEÇ$00001631T.......T.......T.......T.......T.......T.......T.......T.......T.......T.......$00001630$00001923$00002315$000022D9$00000CA6$00000ACD$00000B08$00000759$FFE9B44A$FFE9B44A$FFE9B44A$00000759$000005C3$000013FD$0000190C$00001923ÉÇé*)